home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / lisp / wcl-21.lha / wcl-2.1 / src / compiler / cross / cl-macros.lisp next >
Lisp/Scheme  |  1992-09-10  |  18KB  |  611 lines
  1. ;;; (C) Copyright 1990-1992 by Wade L. Hennessey. All rights reserved.
  2.  
  3. (in-package "W")
  4.  
  5. (defvar *primary-function-info* (make-hash-table :size 3000))
  6.  
  7. (defvar *new-function-info* nil)
  8.  
  9. (defmacro-w defmacro (name lambda-list &body body)
  10.   `(define-macro ',name
  11.     ,(parse-macro-definition name lambda-list nil body)))
  12.  
  13. (defmacro-w defmacro-w (name lambda-list &body body)
  14.   `(define-macro ',name
  15.     ,(parse-macro-definition name lambda-list nil body)))
  16.  
  17. (defmacro-w deftype (name lambda-list &body body)
  18.   `(define-type
  19.     ',name
  20.     ,(parse-macro-definition name lambda-list '* body)))
  21.  
  22. (defmacro-w deftype-w (name lambda-list &body body)
  23.   `(define-type
  24.     ',name
  25.     ,(parse-macro-definition name lambda-list '* body)))
  26.  
  27. (defmacro-w define-compiler-macro (name lambda-list &body body)
  28.   `(define-compiler-macro-1 ',name
  29.     ,(parse-macro-definition name lambda-list nil body)))
  30.  
  31. ;;;  Cl macros.
  32. (defmacro-w check-arg-type (arg type position)
  33.   `(unless (typep ,arg ,type)
  34.      (wta ,arg ,type ,position)))
  35.  
  36. (defmacro-w defmethod (name lambda-list &body body)
  37.   (loop for v in lambda-list
  38.     for rest on lambda-list by #'cdr
  39.     collect (if (listp v) (first v) v) into requireds
  40.     collect (if (listp v) (second v) t) into in-types
  41.     when (or (null (cdr rest))
  42.          (member v lambda-list-keywords :test #'eq))
  43.     return (let ((real-lambda-list (append requireds (cdr rest)))
  44.              (real-body (wrap-in-block name body)))
  45.          `(define-function ',name :defmethod ',in-types 'nil
  46.            ',real-body
  47.            (named-function ,name
  48.              (lambda ,real-lambda-list
  49.                ,@(wrap-in-block
  50.               name
  51.               (append (mapcar #'(lambda (var type) 
  52.                           `(check-arg-type
  53.                         ;; HEY! fix index
  54.                         ,var ',type 0)) 
  55.                       requireds
  56.                       in-types)
  57.                   body))))
  58.            (named-function ,name
  59.             (lambda ,real-lambda-list ,@real-body))))))
  60.  
  61. (defun wrap-in-block (block-name decls+body)
  62.   (multiple-value-bind (body decls)
  63.       (parse-body decls+body)
  64.     `((declare ,@decls) (block ,block-name ,@body))))
  65.   
  66. (defmacro-w defun-1 (name lambda-list &body body)
  67.   (let ((real-body (wrap-in-block name body)))
  68.     `(define-function ',name :defun 'nil 'nil
  69.       ',real-body
  70.       ',nil
  71.       (named-function ,name 
  72.        (lambda ,lambda-list ,@real-body)))))
  73.  
  74. (defmacro-w defun (name formals &body body)
  75.   (cond ((symbolp name)
  76.          `(defun-1 ,name ,formals ,@body))
  77.         ((and (consp name) (eq (car name) 'setf))
  78.          `(progn 
  79.        (defun-1 ,(setf-function-symbol name) ,formals ,@body)
  80.        (defsetf ,(second name) ,(cdr formals) (,(car formals))
  81.          (list ',(setf-function-symbol name) ,@formals))))
  82.     (t (error "~A is not a legal function specifier" name))))
  83.  
  84. (defmacro-w defvar (name &optional init-form doc-string)
  85.   `(define-variable ',name ,init-form ,doc-string :VAR))
  86.  
  87. (defmacro-w defparameter (name init-form &optional doc-string)
  88.   `(define-variable ',name ,init-form ,doc-string :PARAMETER))
  89.  
  90. (defmacro-w defconstant (name init-form &optional doc-string)
  91.   `(define-variable ',name ,init-form ,doc-string :CONSTANT))
  92.  
  93. ;;; HEY! This is an inefficient hack for now...
  94. (defmacro-w destructuring-bind (vars form &body body)
  95.   (labels ((walk-vars (expr path)
  96.          (if (atom expr)
  97.          (if (null expr)
  98.              expr
  99.              `((,expr ,path)))
  100.          (append (walk-vars (car expr) `(car ,path))
  101.              (walk-vars (cdr expr) `(cdr ,path))))))
  102.     (let ((f (gensym "FORM-")))
  103.       `(let ((,f ,form))
  104.     (let ,(walk-vars vars f) ,@body)))))
  105.  
  106. (defmacro-w setf (&rest pairs)
  107.   `(progn
  108.     ,@(loop for rest on pairs by #'cddr
  109.        collect (let ((place (macroexpand-w (first rest)))
  110.              (value (second rest)))
  111.          (multiple-value-bind (tvars vals svars store access)
  112.              (get-setf-method-w place)
  113.            (declare (ignore access))
  114.            (let* ((stores (mapcar #'list svars (list value)))
  115.               (tmps (mapcar #'list tvars vals)))
  116.              `(let* (,@stores
  117.                  ,@tmps)
  118.                ,store)))))))
  119.  
  120.  
  121. (defvar *setf-methods* (make-hash-table :test #'eq))
  122.  
  123. (defmacro-w define-setf-method (accessor lambda-list &body body)
  124.   `(define-setf ',accessor
  125.     ,(parse-macro-definition accessor lambda-list nil body)))
  126.  
  127. (defmacro-w defsetf (accessor name-or-args &rest stuff)
  128.   (if (null stuff)
  129.       `(define-setf ',accessor ',name-or-args)
  130.       (let ((updater  (destructuring-bind ((value-var) . body) stuff
  131.             `(apply #'(lambda (,value-var ,@name-or-args)
  132.                     ,@body)
  133.               svar
  134.               tvars))))
  135.     `(define-setf ',accessor
  136.       #'(lambda (access env)
  137.           (let ((svar (gensym "S"))
  138.             (tvars (loop for arg in (cdr access)
  139.                  collect (gensym "T"))))
  140.         (values tvars
  141.             (cdr access)
  142.             (list svar)
  143.             ,updater
  144.             `(,(first access) ,@tvars))))))))
  145.  
  146. (defmacro defsetf-w (accessor name-or-args &rest stuff)
  147.   (let ((updater (if (null stuff)
  148.              `(list* ',name-or-args (append tvars (list svar)))
  149.              (destructuring-bind ((value-var) . body) stuff
  150.                `(apply #'(lambda (,value-var ,@name-or-args)
  151.                    ,@body)
  152.              svar
  153.              tvars)))))
  154.     `(define-setf ',accessor
  155.       #'(lambda (access env)
  156.       (let ((svar (gensym "S"))
  157.         (tvars (loop for arg in (cdr access) collect (gensym "T"))))
  158.         (values tvars
  159.             (cdr access)
  160.             (list svar)
  161.             ,updater
  162.             `(,(first access) ,@tvars)))))))
  163.  
  164. (defun get-setf-method-w (form &optional env)
  165.   ;; HEY! This is a hack. The correct version of this lives in
  166.   ;; the library.
  167.   (let ((access (macroexpand-w form env)))
  168.     (etypecase access
  169.       (symbol (let ((svar (gensym "S")))
  170.         (values nil nil (list svar) `(setq ,access ,svar) access)))
  171.       (list (let ((expander (gethash (car access)  *setf-methods*)))
  172.           (if (null expander)
  173.           (error "No SETF method found for ~A" access)
  174.           (if (symbolp expander)
  175.               (let ((svar (gensym "S"))
  176.                 (tvars (loop for arg in (cdr access)
  177.                      collect (gensym "T"))))
  178.             (values tvars
  179.                 (cdr access)
  180.                 (list svar)
  181.                 `(,expander ,@tvars ,svar)
  182.                 (cons (first access) tvars)))
  183.               (funcall expander access env))))))))
  184.  
  185. (defun define-setf (accessor updater)
  186.   (setf (gethash accessor *setf-methods*) updater)
  187.   accessor)
  188.  
  189. (defsetf-w car set-car)
  190.  
  191. (defsetf-w cdr set-cdr)
  192.  
  193. (defsetf-w first set-car)
  194.  
  195. (defsetf-w second (x) (new-value)
  196.        `(set-car (cdr ,x) ,new-value))
  197.  
  198. (defsetf-w third (x) (new-value)
  199.        `(set-car (cddr ,x) ,new-value))
  200.  
  201. (defsetf-w fourth (x) (new-value)
  202.        `(set-car (cdddr ,x) ,new-value))
  203.  
  204. (defsetf-w fifth (x) (new-value)
  205.        `(set-car (cddddr ,x) ,new-value))
  206.  
  207. (defsetf-w sixth (x) (new-value)
  208.        `(set-car (nthcdr 5 ,x) ,new-value))
  209.  
  210. (defsetf-w seventh (x) (new-value)
  211.        `(set-car (nthcdr 6 ,x) ,new-value))
  212.  
  213. (defsetf-w eigth (x) (new-value)
  214.        `(set-car (nthcdr 7 ,x) ,new-value))
  215.  
  216. (defsetf-w ninth (x) (new-value)
  217.        `(set-car (nthcdr 8 ,x) ,new-value))
  218.  
  219. (defsetf-w tenth (x) (new-value)
  220.        `(set-car (nthcdr 9 ,x) ,new-value))
  221.        
  222. (defsetf-w aref (array &rest indices)  (new-value)
  223.        `(set-aref ,new-value ,array ,@indices))
  224.  
  225. (defsetf-w sbit (array &rest indices)  (new-value)
  226.   `(set-sbit ,new-value ,array ,@indices))
  227.  
  228. (defsetf-w svref set-svref)
  229.  
  230. (defsetf-w schar set-schar)
  231.  
  232. (defsetf-w 32bit-vref set-32bit-vref)
  233.  
  234. (defsetf-w symbol-value set)
  235.  
  236. (defsetf-w symbol-function set-symbol-function)
  237.  
  238. (defsetf-w symbol-plist set-symbol-plist)
  239.  
  240. (defsetf-w symbol-package set-symbol-package)
  241.  
  242. (defsetf-w symbol-hash-code set-symbol-hash-code)
  243.  
  244. (defsetf-w get (symbol indicator) (new-value)
  245.        `(progn (set-get ,symbol ,indicator ,new-value)
  246.          ,new-value))
  247.  
  248. (defsetf-w fill-pointer set-fill-pointer)
  249.  
  250. ;;; HEY! This isn't quite right.....see the manual
  251. ;;;(defmacro-w define-modify-macro (name lambda-list function &optional docstr)
  252. ;;;  `(defmacro-w ,name (reference . ,lambda-list)
  253. ;;;     (setf ,reference (,function reference ,lambda-list-args))))
  254. ;;;(define-modify-macro incf (&optional (delta 1)) +)
  255.  
  256. (defmacro-w incf (ref &optional (delta 1))
  257.      `(setf ,ref (+ ,ref ,delta)))
  258.  
  259. (defmacro-w decf (ref &optional (delta 1))
  260.      `(setf ,ref (- ,ref ,delta)))
  261.  
  262. (defmacro-w remf (place indicator)
  263.      `(setf ,place (delete-property ,place ,indicator)))
  264.  
  265. (defmacro-w pop (var)
  266.      (let ((list (gensym "LIST")))
  267.        `(let ((,list ,var))
  268.          (prog1 (car ,list)
  269.            (setf ,var (cdr ,list))))))
  270.  
  271. (defmacro-w push (value-form var)
  272.      (let ((value (gensym "VALUE")))
  273.        `(let ((,value ,value-form))
  274.          (setf ,var (cons ,value ,var)))))
  275.  
  276. (defmacro-w return (&optional (value nil))
  277.      `(return-from nil ,value))
  278.  
  279. (defmacro-w when (pred &rest args)
  280.   `(if ,pred
  281.     (progn ,@args)
  282.     nil))
  283.  
  284. (defmacro-w unless (pred &rest args)
  285.   `(if (not ,pred)
  286.     (progn ,@args)
  287.     nil))
  288.  
  289.  
  290. (defmacro-w psetq (&rest vars+vals)
  291.   (let* ((vars (every-even vars+vals))
  292.      (vals (every-odd vars+vals))
  293.      (tmps (n-list (length vars) #'(lambda () (gensym "TMP")))))
  294.     `(let ,(mapcar #'list tmps vals)
  295.       (setq ,@(mapcan #'list vars tmps))
  296.       nil)))
  297.  
  298. ;;; HEY! change to use (end . result) no the destructuring-bind works.
  299. (defmacro-w do (step-forms (end &rest result) &body decls+body)
  300.   (let ((vars (mapcar #'first step-forms))
  301.     (inits (mapcar #'second step-forms))
  302.     (test-label (gensym "TEST"))
  303.     (loop-label (gensym "LOOP")))
  304.     (multiple-value-bind (body decls)
  305.     (parse-body decls+body)
  306.       `(block nil
  307.     (let ,(mapcar #'list vars inits)
  308.       (declare ,@decls)
  309.       (tagbody (go ,test-label)    ; loop inversion
  310.          ,loop-label
  311.          (psetq ,@(mapcan #'(lambda (unit)
  312.                   (if (null (cddr unit)) ; no step form?
  313.                       nil
  314.                       (list (first unit) (third unit))))
  315.                   step-forms))
  316.          ,test-label
  317.          (if ,end
  318.          (return (progn ,@result)))
  319.          ,@body
  320.          (go ,loop-label)))))))
  321.  
  322. ;;; HEY! Unify with above?
  323. (defmacro-w do* (step-forms (end &rest result) &body decls+body)
  324.   (let ((vars (mapcar #'first step-forms))
  325.     (inits (mapcar #'second step-forms))
  326.     (test-label (gensym "TEST"))
  327.     (loop-label (gensym "LOOP")))
  328.     (multiple-value-bind (body decls)
  329.     (parse-body decls+body)
  330.       `(block nil
  331.     (let* ,(mapcar #'list vars inits)
  332.       (declare ,@decls)
  333.       (tagbody (go ,test-label)    ; loop inversion
  334.          ,loop-label
  335.          (setq ,@(mapcan #'(lambda (unit)
  336.                  (if (null (cddr unit)) ; no step form?
  337.                      nil
  338.                      (list (first unit) (third unit))))
  339.                  step-forms))
  340.          ,test-label
  341.          (if ,end
  342.          (return (progn ,@result)))
  343.          ,@body
  344.          (go ,loop-label)))))))
  345.  
  346. (defmacro-w dotimes ((var limitform &optional result) &body body)
  347.   `(loop for ,var from 0 below ,limitform do (progn ,@body)
  348.     finally (return ,result)))
  349.  
  350.                     ;  (let ((limit (gensym "LIMIT")))
  351.                     ;    `(do ((,limit ,limitform)
  352.                     ;      (,var 0 (+ ,var 1)))
  353.                     ;      ((= ,var ,limit) ,result)
  354.                     ;      (declare (fixnum ,limit ,var))
  355.                     ;      ,@body)))
  356.  
  357.  
  358. (defmacro-w dolist ((var listform &optional (result nil)) &body body)
  359.   `(loop for ,var in ,listform do (progn ,@body) finally (return ,result)))
  360.  
  361. (defmacro-w prog1 (first &body body)
  362.   (let ((value (gensym "VALUE")))
  363.     `(let ((,value ,first))
  364.       ,@body
  365.       ,value)))
  366.  
  367. (defmacro-w loop (&whole form)
  368.   (macroexpand form))
  369.  
  370. (defmacro-w prog2 (first second &body body)
  371.   (let ((ignore (gensym "TMP"))
  372.     (value (gensym "VALUE")))
  373.     `(let ((,ignore ,first))
  374.       (let ((,value ,second))
  375.     ,@body
  376.     ,value))))
  377.  
  378.        (defmacro-w prog (var-list &body body+decls)
  379.      (multiple-value-bind (body decls)
  380.          (parse-body body+decls)
  381.        `(block nil
  382.          (let ,var-list
  383.            (declare ,@decls)
  384.            (tagbody ,@body)))))
  385.  
  386.        (defmacro-w and (&rest args)
  387.   (if (null args)
  388.       t
  389.       (if (null (rest args))
  390.       (first args)
  391.       `(if ,(first args)
  392.         (and ,@(rest args))
  393.         nil))))
  394.  
  395. (defmacro-w or (&rest args)
  396.   (if (null args)
  397.       nil
  398.       (if (null (rest args))    
  399.       (macroexpand-w (first args))
  400.       (let ((arg (gensym "G")))
  401.         `(let ((,arg ,(first args)))
  402.           (if ,arg
  403.           ,arg
  404.           (or ,@(rest args))))))))
  405.  
  406. (defmacro-w cond (&rest clauses)
  407.   (if (null clauses)
  408.       nil
  409.       (let ((clause (first clauses)))
  410.     (let ((test (first clause))
  411.           (body (rest clause)))
  412.       `(if ,test
  413.         ,(if (null body)
  414.          nil
  415.          `(progn ,@body))
  416.         (cond ,@(rest clauses)))))))
  417.  
  418. (defmacro-w locally (&rest forms)
  419.   `((lambda () ,@forms)))
  420.  
  421. (defmacro-w let (bindings &body body+decls)
  422.   (multiple-value-bind (body decls)
  423.       (parse-body body+decls)
  424.     (if (and (null bindings) (null decls))
  425.     `(progn ,@body)
  426.     `((lambda ,(mapcar #'(lambda (spec)
  427.                    (if (atom spec)
  428.                    spec
  429.                    (first spec)))
  430.                bindings)
  431.     
  432.         (declare ,@decls)
  433.         ,@body)
  434.       ,@(mapcar #'(lambda (spec)
  435.             (if (atom spec)
  436.                 'nil
  437.                 (second spec)))
  438.          bindings)))))
  439.  
  440. (defmacro-w let* (bindings &body body+decls)
  441.   (multiple-value-bind (body decls)
  442.       (parse-body body+decls)
  443.     (if (null bindings)
  444.     (if (null decls)
  445.         `(progn ,@body)
  446.         `(locally ,@body+decls))
  447.     (let ((first-binding (if (atom (first bindings))
  448.                  (list (first bindings) nil)
  449.                  (first bindings))))
  450.       `((lambda ,(if (null bindings)
  451.             nil
  452.             (list (first first-binding)))
  453.           (let* ,(rest bindings) (declare ,@decls) ,@body))
  454.         ,(second first-binding))))))
  455.  
  456. (defmacro-w multiple-value-bind (lambda-list values-form &body body)
  457.   `(mv-bind ,lambda-list ,values-form ,@body))
  458.  
  459. (defmacro-w multiple-value-list (values-form)
  460.   `(multiple-value-call #'(lambda (&rest l) l) ,values-form))
  461.  
  462. (defmacro-w multiple-value-setq (vars form)
  463.   (let ((tmps (mapcar #'(lambda (x)
  464.               (declare (ignore x))
  465.               (gensym "TMP")) vars)))
  466.     `(multiple-value-call #'(lambda (&optional ,@tmps)
  467.                   ,@(loop for v in vars
  468.                       for tmp in tmps
  469.                       collect `(setq ,v ,tmp)))
  470.       ,form)))
  471.       
  472. ;;; HEY! This would be more efficient as a special form
  473. (defmacro-w multiple-value-prog1 (first-form &rest other-forms)
  474.   (let ((value-holder (gensym "MV")))
  475.     `(multiple-value-call #'(lambda (&rest ,value-holder)
  476.                   (progn ,@other-forms 
  477.                      (values-list ,value-holder)))
  478.       ,first-form)))
  479.  
  480. (defmacro-w select (key-form &rest cases)
  481.   (let ((key (gensym "KEY")))
  482.     `(let ((,key ,key-form))
  483.       (cond ,@(loop for (case . consequent) in cases
  484.             collect (cons (if (member case '(t otherwise))
  485.                       t
  486.                       (if (atom case)
  487.                       `(eql ,key ,case)
  488.                       `(or ,@(loop for c in case
  489.                           collect `(eq ,key ,c)))))
  490.                   consequent))))))
  491.  
  492. (defmacro-w case (key-form &rest cases)
  493.   (let ((key (gensym "KEY")))
  494.     `(let ((,key ,key-form))
  495.       (cond ,@(loop for (case . consequent) in cases
  496.             collect (cons (if (member case '(t otherwise))
  497.                       t
  498.                       (list (if (atom case)
  499.                         'eql
  500.                         'member)
  501.                         key
  502.                         `(quote ,case)))
  503.                   consequent))))))
  504.  
  505. (defmacro-w ecase (key &rest cases)
  506.   `(case ,key
  507.     ,@cases
  508.     (t (error "~S is not one of the following constants:~{ ~A~}"
  509.     ,key
  510.     ',(collect-cases cases)))))
  511.  
  512. (defmacro-w typecase (key &rest cases)
  513.   (let ((k (gensym "KEY")))
  514.     `(let ((,k ,key))
  515.       ,(if (and (eq (caar cases) t)    ; single T case?
  516.         (null (cdr cases)))
  517.        `(progn ,@(cdar cases))
  518.        `(cond ,@(loop for (type . consequent) in cases
  519.              collect (if (member type '(t otherwise))
  520.                  `(t ,@consequent)
  521.                  `((typep ,k ',type) ,@consequent))))))))
  522.  
  523. (defmacro-w etypecase (key &rest cases)
  524.   (let ((k (gensym "KEY")))
  525.     `(let ((,k ,key))
  526.       (typecase ,k
  527.     ,@cases
  528.     (t (error "~S is not one of these types:~{ ~A~}"
  529.           ,k
  530.           ',(collect-cases cases)))))))
  531.  
  532. (defmacro-w with-open-file ((stream name &rest options) &body body)
  533.   `(let ((,stream nil))
  534.     (unwind-protect (progn (setq ,stream (open  ,name ,@options))
  535.                ,@body)
  536.       (unless (null ,stream)
  537.     (close ,stream)))))
  538.  
  539. (defmacro-w shiftf (&rest args &environment env)
  540.   "One or more SETF-style place expressions, followed by a single
  541.   value expression.  Evaluates all of the expressions in turn, then
  542.   assigns the value of each expression to the place on its left,
  543.   returning the value of the leftmost."
  544.   (if (< (length args) 2)
  545.       (error "Too few argument forms to a SHIFTF."))
  546.   (let ((leftmost (gensym)))
  547.     (do ((a args (cdr a))
  548.      (let-list nil)
  549.      (setf-list nil)
  550.      (next-var leftmost))
  551.     ((atom (cdr a))
  552.      (push (list next-var (car a)) let-list)
  553.      `(let* ,(nreverse let-list) ,@(nreverse setf-list) ,leftmost))
  554.       (multiple-value-bind (dummies vals newval setter getter)
  555.     (get-setf-method-w (car a) env)
  556.     (do* ((d dummies (cdr d))
  557.           (v vals (cdr v)))
  558.          ((null d))
  559.       (push (list (car d) (car v)) let-list))
  560.     (push (list next-var getter) let-list)
  561.     (push setter setf-list)
  562.     (setq next-var (car newval))))))
  563.  
  564. (defmacro-w rotatef (&rest args &environment env)
  565.   "Takes any number of SETF-style place expressions.  Evaluates all of the
  566.   expressions in turn, then assigns to each place the value of the form to
  567.   its right.  The rightmost form gets the value of the leftmost.  Returns NIL."
  568.   (cond ((null args) nil)
  569.     ((null (cdr args)) `(progn ,(car args) nil))
  570.     (t (do ((a args (cdr a))
  571.         (let-list nil)
  572.         (setf-list nil)
  573.         (next-var nil)
  574.         (fix-me nil))
  575.            ((atom a)
  576.           (rplaca fix-me next-var)
  577.           `(let* ,(nreverse let-list) ,@(nreverse setf-list) nil))
  578.            (multiple-value-bind (dummies vals newval setter getter)
  579.                  (get-setf-method-w (car a) env)
  580.          (do ((d dummies (cdr d))
  581.               (v vals (cdr v)))
  582.              ((null d))
  583.            (push (list (car d) (car v)) let-list))
  584.          (push (list next-var getter) let-list)
  585.          ;; We don't know the newval variable for the last form yet,
  586.          ;; so fake it for the first getter and fix it at the end.
  587.          (unless fix-me (setq fix-me (car let-list)))
  588.          (push setter setf-list)
  589.          (setq next-var (car newval)))))))
  590.  
  591. (defmacro-w pushnew (item place &key (test '#'eql) test-not (key '#'car))
  592.   `(setf ,place (adjoin/4 ,item ,place ,test ,key)))
  593.  
  594. (defmacro-w loop-finish () 
  595.   '(go end-loop))
  596.  
  597. (defmacro-w declaim (&rest decl-specs)
  598.   `(progn ,@(loop for spec in decl-specs collect `(proclaim ',spec))))
  599.  
  600. (defmacro-w defun-inline (name &rest stuff)
  601.   `(progn (declaim (inline ,name))
  602.     (defun ,name ,@stuff)))
  603.  
  604. (defmacro-w defmethod-inline (name &rest stuff)
  605.   `(progn (declaim (inline ,name))
  606.     (defmethod ,name ,@stuff)))
  607.  
  608. (defmacro-w backquote (x)
  609.   (bq-completely-process x))
  610.  
  611.